home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / m68gen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.8 KB  |  307 lines
  1. (herald (back_end m68gen)
  2.   (env t (orbit_top defs) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define (generate-nil-test arg)
  28.   (emit m68/cmp .l arg nil-reg))
  29.     
  30. ;;; Eq?
  31. ;;; ---------------------------------------------------------------------
  32.  
  33.  
  34. (define (eq?-comparator node)
  35.   (destructure (((then else () ref1 ref2) (call-args node)))
  36.     (let ((val1 (leaf-value ref1))
  37.           (val2 (leaf-value ref2)))
  38.       (let ((access2 (access-with-rep node val2 'rep/pointer)))
  39.         (protect-access access2)
  40.         (let ((access1 (access-with-rep node val1 'rep/pointer)))
  41.           (cond ((or (register? access1) (eq? access1 nil-reg))
  42.                  (emit m68/cmp .l access2 access1))
  43.                 ((or (register? access2) (eq? access2 nil-reg))
  44.                  (emit m68/cmp .l access1 access2))
  45.                 (else
  46.                  (let ((reg (get-register 'pointer node '*)))
  47.                    (emit m68/move .l access1 reg)
  48.                    (emit m68/cmp .l access2 reg))))
  49.           (emit-jump 'jneq else then)
  50.           (release-access access2))))))
  51.  
  52.  
  53. (define (one-arg-primitive node)
  54.   (destructure (((cont arg) (call-args node)))
  55.     (receive (t-spec t-rep) (continuation-wants cont)
  56.       (let* ((var (leaf-value arg))
  57.              (dest (cond ((register? t-spec)
  58.                           (cond ((or (not (reg-node t-spec))
  59.                                      (dying? (reg-node t-spec) node))
  60.                                   t-spec)
  61.                                 (else
  62.                                  (get-register (reg-type t-spec) node '*))))
  63.                          ((and (dying? var node) (register-loc var))
  64.                           => (lambda (reg)
  65.                                (if (and (register? reg) (eq? (reg-type reg) t-spec))
  66.                                    reg
  67.                                    (get-register t-spec node '*))))
  68.                          (else
  69.                           (get-register t-spec node '*)))))
  70.         (lock dest)
  71.         (let ((acc (access-value node var)))
  72.           (unlock dest)
  73.           (kill-if-dying var node)
  74.           (return acc dest t-rep))))))
  75.  
  76.  
  77. (define (generate-closure-enclosing-object node)
  78.      (receive (source target rep) (one-arg-primitive node)
  79.        (let ((creg (cond ((and (register? source) (neq? source target))
  80.                           source)
  81.                          (else
  82.                           (lock target)
  83.                           (block0 (get-register 'pointer node '*)
  84.                                   (unlock target))))))
  85.          (generate-move source creg)
  86.          (emit m68/move .l (reg-offset creg -2) target)   ; get template
  87.          (emit m68/move .l (machine-num 0) SCRATCH)
  88.          (emit m68/move .w (reg-offset target -6) SCRATCH) ; offset field in bytes
  89.          (generate-move creg target)
  90.          (emit m68/sub .l SCRATCH target))    ; pointer and scratch adjoined
  91.          (mark-continuation node target)))
  92.  
  93.  
  94. (define (generate-make-vector-extend node)
  95.   (destructure (((#f type length size) (call-args node)))
  96.     (let ((acc (access-with-rep node (leaf-value length) 'rep/pointer)))
  97.       (free-register node AN)
  98.       (emit m68/move .l acc SCRATCH)
  99.       (emit m68/asl .l (machine-num 6) SCRATCH)
  100.       (emit m68/move .b (machine-num (leaf-value type)) SCRATCH)
  101.       (emit m68/move .l SCRATCH AN)
  102.       (lock AN))
  103.     (let ((acc (access-with-rep node (leaf-value size) 'rep/pointer)))
  104.       (free-register node S1)
  105.       (generate-move acc S1))
  106.     (free-register node S2)
  107.     (generate-slink-jump slink/make-extend)
  108.     (unlock AN)
  109.     (mark-continuation node AN)))
  110.  
  111.  
  112. (define (generate-make-extend node)
  113.   (destructure (((#f template size) (call-args node)))
  114.     (let ((acc (access-with-rep node (leaf-value template) 'rep/pointer)))
  115.       (free-register node AN)
  116.       (generate-move acc AN)
  117.       (lock AN))
  118.     (let ((acc (access-with-rep node (leaf-value size) 'rep/pointer)))
  119.       (free-register node S1)
  120.       (generate-move acc S1))
  121.     (free-register node S2)
  122.     (generate-slink-jump slink/make-extend )
  123.     (unlock AN)
  124.     (mark-continuation node AN)))
  125.      
  126.                                              
  127. (define (generate-make-cell node)
  128.   (let ((cont ((call-arg 1) node)))
  129.     (cond ((and (lambda-node? cont)
  130.                 (eq? (variable-definition (car (lambda-variables cont))) 'one))
  131.            (receive (t-spec t-rep) (continuation-wants cont)
  132.              (mark-continuation node (get-target-register node t-spec))))
  133.           (else
  134.            (free-register node AN)
  135.            (free-register node S1)
  136.            (emit m68/move .l (lit 1) S1)               ; 1 slot
  137.            (emit m68/move .l (machine-num header/cell) AN)
  138.            (free-register node S2)
  139.            (lock AN)
  140.            (generate-slink-jump slink/make-extend )
  141.            (unlock AN)
  142.            (mark-continuation node AN)))))
  143.  
  144. (define (generate-make-pair node)
  145.   (free-register node AN)
  146.   (generate-slink-jump slink/make-pair)
  147.   (mark-continuation node AN))           
  148.  
  149.  
  150. (define (generate-slink-ref node)
  151.   (generate-primitive-reg-ref node 'slink))
  152.  
  153. (define (generate-task-ref node)
  154.   (generate-primitive-reg-ref node 'task))
  155.  
  156. (define (generate-set-slink-ref node)
  157.   (generate-set-primitive-reg-ref node 'slink))
  158.  
  159. (define (generate-set-task-ref node)
  160.   (generate-set-primitive-reg-ref node 'task))
  161.  
  162.  
  163. (define (generate-primitive-reg-ref node reg)
  164.   (destructure (((cont arg) (call-args node)))
  165.    (if (fixnum? (leaf-value arg))
  166.     (receive (t-spec t-rep) (continuation-wants cont)
  167.       (let ((dest (get-target-register node t-spec)))
  168.         (xcase reg
  169.       ((slink) (really-rep-convert node (d@nil (leaf-value arg)) 'rep/pointer
  170.                             dest t-rep))
  171.       ((task) (really-rep-convert node (reg-offset TASK (leaf-value arg))
  172.                       'rep/pointer dest t-rep)))
  173.         (mark-continuation node dest))))))
  174.                                                                   
  175.  
  176. (define (generate-set-primitive-reg-ref node reg)
  177.   (destructure (((#f arg val) (call-args node))) 
  178.    (if (fixnum? (leaf-value arg))
  179.        (let ((acc (access-with-rep node (leaf-value val) 'rep/pointer)))
  180.          (xcase reg
  181.        ((slink) (emit m68/move .l acc (d@nil (leaf-value arg))))
  182.        ((task) (emit m68/move .l acc (reg-offset TASK (leaf-value arg)))))))))
  183.  
  184.                  
  185.  
  186. (define (generate-stack-pointer node)
  187.   (receive (t-spec t-rep) (continuation-wants ((call-arg 1) node))
  188.     (let ((dest (get-target-register node t-spec)))
  189.       (free-register node dest)
  190.       (emit m68/move .l SP dest)
  191.       (mark-continuation node dest))))
  192.   
  193.  
  194. (define (generate-current-continuation node)
  195.   (receive (t-spec t-rep) (continuation-wants ((call-arg 1) node))
  196.     (let ((dest (get-target-register node t-spec)))
  197.       (free-register node dest)
  198.       (emit m68/move .l SP dest)
  199.       (emit m68/add .l (machine-num 2) dest)
  200.       (mark-continuation node dest))))
  201.  
  202.            
  203. (define (generate-nary-setup node required)
  204.   (if (eq? (lambda-strategy node) strategy/stack)
  205.       (emit m68/neg .l NARGS))                           ; !!!
  206.   (do ((i (fx+ A1 required) (fx+ i 1)))
  207.       ((fx>= i (fx- *real-registers* 1)))
  208.     (generate-move i (fx+ *real-registers* (fx- i A1))))
  209.   (generate-move (machine-num required) S0)
  210.   (generate-slink-jump slink/nary-setup)
  211.   (mark (lambda-rest-var node) AN))
  212.  
  213.  
  214. ;;; GENERATE-HANDLER The situation is that the object is in A1 and its template 
  215. ;;; is in TP.  The  operation is in P.  We must use only the register AN.                                 
  216.  
  217. (define (hacked-get-register type node where) 
  218.   (ignore type node where)
  219.   (cond ((reg-node an)
  220.      => (lambda (x)
  221.           (set (register-loc x) nil)
  222.           (set (reg-node an) nil))))
  223.   AN)
  224.  
  225. (define (generate-handler node)                            
  226.   (let ((leaves (call-args (lambda-body ((call-arg 3) (lambda-body node)))))
  227.         (methods (cdddr (call-args (lambda-body node)))))
  228.     (cond ((null? methods)
  229.            (emit m68/move .l nil-reg AN)
  230.            (emit m68/rts))
  231.           (else
  232.       (bind ((get-register hacked-get-register))
  233.         (mark (lambda-self-var *lambda*) A1)
  234.         (generate-jump (car leaves))
  235.         (let ((last ((call-arg 3) (lambda-body node))))
  236.           (do ((l leaves (cdr l))
  237.                (methods methods (cdr methods)))
  238.               ((null? l)
  239.                (emit-tag last)
  240.                (emit m68/move .l nil-reg AN)
  241.                (emit m68/rts)
  242.                (clear-slots))
  243.             (generate-handler-test (car l) 
  244.                                    (car methods) 
  245.                                    (if (null? (cdr l)) last (cadr l))))))))))
  246.  
  247. (define (generate-handler-test leaf method next)
  248.   (emit-tag leaf)
  249.   (emit m68/cmp .l (access-value nil (leaf-value leaf)) P)
  250.   (let ((el-hacko (cons nil nil)))
  251.     (emit-jump 'jneq next el-hacko)
  252.     (emit-tag el-hacko))
  253.   (lambda-queue method)
  254.   (generate-move-address (template method) AN)
  255.   (emit m68/rts))
  256.   
  257.  
  258. (define (generate-undefined-effect node)
  259.   (generate-move (access-value node (leaf-value ((call-arg 1) node))) A1)
  260.   (generate-jump-absolute (*d@nil slink/undefined-effect))
  261.   (clear-slots))
  262.  
  263.  
  264. (define (generate-vframe-test amount)
  265.   (let ((hack1 (cons nil nil))
  266.         (hack2 (cons nil nil)))
  267.     (emit m68/cmp .b (machine-num header/vframe) (d@r 15 3))
  268.     (emit-jump 'jneq hack2 hack1)
  269.     (emit-tag hack1)                       
  270.     (adjust-stack-pointer amount)
  271.     (generate-jump hack2)
  272.     (emit-tag hack2)))
  273.         
  274.  
  275. (define (generate-set node location value)
  276.   (let ((access (if (lambda-node? value)        
  277.             (cond ((access/make-closure node value))
  278.               (else AN))
  279.             (access-with-rep node (leaf-value value) 'rep/pointer))))
  280.     (protect-access access)
  281.     (let ((loc (lookup node (get-lvalue (leaf-value location)) nil))
  282.       (hack1 (cons nil nil))
  283.       (hack2 (cons nil nil)))
  284.       (let ((reg (get-register 'pointer node '*)))
  285.     (release-access access)
  286.     (generate-move loc reg)
  287.     (generate-move access (reg-offset reg 2))
  288.     (emit m68/tst .b (reg-offset reg 0))
  289.     (emit-jump 'jneq hack1 hack2)
  290.     (emit-tag hack1)                       
  291.     (emit m68/move .l reg (reg-offset TASK task/extra-pointer))
  292.     (generate-slink-jump slink/set)
  293.     (generate-jump hack2)
  294.     (emit-tag hack2)))))
  295.  
  296. (define (generate-remove-state-object node)
  297.   (let ((cont (car (call-args node))))
  298.     (if (and (lambda-node? cont)
  299.          (not (lambda-rest-var cont))
  300.          (variable-refs (lambda-cont-var cont)))
  301.     (receive (t-spec t-rep) (continuation-wants cont)
  302.       (let ((dest (get-target-register node t-spec)))
  303.         (emit m68/move .l (reg-offset sp 4) dest)
  304.         (mark-continuation node dest)))))
  305.   (or (not (method-lambda (node-parent node)))
  306.       (emit m68/add .w ($ 20) sp)))
  307.